home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / OTHER_LA / YERK__ / TOOLBOX_ / QD1 < prev    next >
Text File  |  1986-09-20  |  4KB  |  172 lines
  1. \ qd1 - more QuickDraw objects
  2. \ 12/14/84  cbd Version 1
  3. \ 11/16/85  cdn Added disp: method to Picture & Icon
  4. Decimal
  5.  
  6. : +pair  { x1 y1 x2 y2 -- x1+y1 x2+y2 }  x1 x2 + y1 y2 +  ;
  7.  
  8. \ Interface object for QD picture support
  9. :CLASS Picture  <Super Object
  10.  
  11.     Handle    picHndl
  12.     Int        resID        \ resource ID if it is a resource
  13.     Rect    DestRect    \ destination rectangle for drawing
  14.  
  15.     \ ( l t r b -- )  Open a new pict with given frame
  16.     :M  OPEN:  Put: tempRect  0 abs: tempRect call OpenPicture
  17.         Put: picHndl  ;M
  18.  
  19.     \ ( -- )  terminate this picture definition
  20.     :M  CLOSE:  call ClosePicture   ;M
  21.  
  22.     \ ( resID -- )
  23.     :M INIT:  put:  resID  ;M
  24.  
  25.     \ load the picture from a resource file
  26.     :M  GETNEW:  0 int: resID  call GetPicture  put: picHndl
  27.         ptr: picHndl  2+ get: rect  put: destRect   ;M
  28.  
  29.     \ ( w h -- )  Set size in pixels of dest rect
  30.     :M  SIZE:   getTop:  destRect  +Pair  putBot: destRect ;M
  31.  
  32.     \ ( x y -- )  Move dest rect to given location
  33.     :M  GOTO:  { x y -- }   Size: destRect  x y putTop: DestRect
  34.         Size: self  ;M
  35.  
  36.     \ ( -- )  Draw the picture in destRect
  37.     :M  DRAW:  get: picHndl abs: destRect
  38.         call DrawPicture   ;M
  39.  
  40.     \ ( x y resID -- )  Combines the actions of init:, getNew:, goto: & draw:
  41.     :M  DISP:  init: self  getNew: self  goto: self  draw: self  ;M
  42.  
  43.     \ ( -- )  dispose of picture heap
  44.     :M  KILL:  get: picHndl  call KillPicture   ;M
  45.  
  46. ;CLASS
  47.  
  48. \ resource-based Icon
  49.  
  50. :CLASS Icon  <Super Object
  51.  
  52.     Handle    theHandle
  53.     Int        resID
  54.     Rect    theRect
  55.  
  56.     \ ( resID -- )  set the resource ID
  57.     :M  INIT:  put: resID    ;M
  58.  
  59.     \ load the icon from a resource file
  60.     :M  GETNEW:   0 int: resID  call GetIcon   put: theHandle  ;M
  61.  
  62.     \ ( x y -- )  move topLeft corner to x,y
  63.     :M  GOTO:  { x y -- }  x y  x 32 + y 32 +  put: theRect  ;M
  64.  
  65.     \ draw the icon at current location
  66.     :M  DRAW:  abs: theRect  get: theHandle  call PlotIcon  ;M
  67.  
  68.     \ ( x y resID -- )  Combines the actions of init:, getNew:, goto: & draw:
  69.     :M  DISP:  init: self  getNew: self  goto: self  draw: self ;M
  70.  
  71. ;CLASS
  72.  
  73. \ define the quickDraw bitmap object
  74. :CLASS qdBitMap  <Super Object
  75.  
  76.     Var        BaseAddr
  77.     Int        RowBytes
  78.     Rect    BndsRect
  79.  
  80.     \ ( addr n  l t r b -- )
  81.     :M  PUT:   Put:  bndsRect  Put: RowBytes
  82.         Put: BaseAddr  ;M
  83.  
  84. ;CLASS
  85.  
  86. \ rounded rectangle
  87. :CLASS RndRect  <Super Rect
  88.  
  89.     Point    ovalSize    \ size in pixels of ovals at corners
  90.  
  91.     \ ( w h -- )  set width, height of corners
  92.     :M  INIT:  put: ovalSize  ;M
  93.  
  94.     \  ( -- )
  95.     :M  DRAW:  (abs) int: ovalSize call FrameRoundRect  ;M
  96.  
  97.     :M  PRINT:  Draw:  Self  ;M
  98.  
  99.     :M  CLEAR:  (abs) int: ovalSIze  call EraseRoundRect   ;M
  100.  
  101.     \ ( ^patObj -- )  Fill rect with pattern )
  102.     :M  FILL:  { pat -- }
  103.         (abs) int: ovalSize  pat +base  call FillRoundRect   ;M
  104.  
  105.     \ ( -- x y )
  106.     :M  CENTER:   { \ x y -- }  Size: Self  2/  -> y  2/ -> x
  107.         GetX: TopL  x +    getY: topL y +   ;M
  108.  
  109.     \ ( -- )
  110.     :M  INVERT: (abs) int: ovalSize call InverRoundRect ;M
  111.  
  112.     \ ( -- )
  113.     :M  PAINT:  (abs) int: ovalSize call PaintRoundRect ;M
  114.  
  115. ;CLASS
  116.  
  117. \ QuickDraw ovals - data is same as a Rect
  118. :CLASS Oval  <Super Rect
  119.  
  120.     \ ( -- )
  121.     :M  DRAW:  (abs) call FrameOval   ;M
  122.  
  123.     \ ( -- )
  124.     :M  CLEAR:  (abs) call EraseOval  ;M
  125.  
  126.     \ ( -- )
  127.     :M  PAINT:  (abs) call PaintOval  ;M
  128.  
  129.     :M  FILL:  { pat -- }  (abs) pat +base call FillOval   ;M
  130.  
  131.     :M  INVERT:  (abs) call InvertOval  ;M
  132.  
  133. ;CLASS
  134.  
  135. \ Variable-length image object for bit images
  136. \  E.G., an Icon would have 32 cells, rowbytes=4
  137. :CLASS Image  <Super Array
  138.  
  139.     Var        BaseAddr
  140.     Int        RowBytes    \ Source bitMap
  141.     Rect    bndsRect
  142.     Var        DestBits    \ addr of destination bit image
  143.     Int        Mode
  144.     Rect    Destrect    \ Destination rect for CopyBits
  145.  
  146.     \ ( -- )  Set the source, destination bitmap ptrs
  147.     :M  GETPORT:  Abs: DestBits  call GetPort 2 +: DestBits
  148.         0  ^elem: self   +base  Put: baseAddr   ;M
  149.  
  150.     \ ( mode rowBytes topX topY -- )
  151.     :M  INIT:  { themode rBytes topX topY -- }  themode Put: mode
  152.         rBytes Put: RowBytes topX topY PutTop: bndsRect
  153.         rBytes 8 * topX +    \ # of bits in a row + topX
  154.         limit: self  width: self * rBytes / topY +    \ # of rows + topy
  155.         PutBot: bndsRect
  156.         GetPort: Self   ;M
  157.  
  158.     \ ( x  y -- )  Move location without drawing
  159.     :M  GOTO:  { xloc yloc -- }  xloc  yloc Puttop: DestRect
  160.         size: bndsRect  xloc yloc +Pair  PutBot: destRect   ;M
  161.  
  162.     \ ( -- )  Draw the image at its current location
  163.     :M  DRAW:    (abs)  Get: DestBits  Abs: bndsRect  Abs: DestRect
  164.         Int: Mode  0 call CopyBits  ;M
  165.  
  166.     \ ( x y -- )  Goto a location and draw the image
  167.     :M  MOVETO:  Goto: Self Draw: Self   ;M
  168.  
  169.     :M  CLASSINIT: srcXor 2 0 0  Init: Self 0 0 Goto: self ;M
  170.  
  171. ;CLASS
  172.